The Programmer Disk/The Programmer Disk (Microforum).iso/xpro/pascal/pro2/3dgraph.pas

Pascal/Delphi Source File | 1986-12-02 | 43KB | 1,325 lines

program graph2 ;  (*    4/5/86  Joe Martin 862-7108  *)

{$D-}
{$V-}
Label Finish , Cross , start ;

CONST
   MaxX : integer = 640 ; MaxY : integer=400 ;
   THETA : REAL=0.3 ; PHI : REAL=1.2 ;    OBJECT: Real=50   ;
      LowX : REAL=-10 ; HighX : REAL=10 ;       IMAGE: Real=750  ;
      LowY : REAL=-10; HighY : REAL=10 ; XIncrement : REAL=0.5 ;
    CenterX: Real=200 ; CenterY: Real=100 ; YIncrement : real=0.5 ;
    ScaleX : Real=2 ; ScaleY : Real=1 ;
   space='                                                                           ' ;
   F1 = #59 ;
Type
    NodeType = (binop,unop,number) ;
    Node     = ^NodeRec ;
    NodeRec  = Record
                     Case Tag : NodeType of
                      binop : (operator : Char ;
                               LeftOperand,
                               RightOperand : Node) ;
                      unop  : (Uoperator : Char ;
                               Operand   : Node) ;
                    Number  : (Num : Real) ;
                     End ; {  case  }
    Pair = record
                 x : integer ;
                 y : integer ;
           end ;
    PBytePointer = ^P_Byte ;
    P_Byte = array[1..400,0..79] of byte ;

    PairPointer  = ^Pt ;
    SPairPointer = ^SPt ;
    Pt  = array[1..90,1..152] of pair ;
    SPt = array[1..90,1..152] of pair ;

    EvenVideo = array[0..99,0..79] of byte ;
    OddVideo  = array[0..99,0..79] of byte ;

    anystring = string[80] ;
    str80     = string[80] ;
    str20     = string[20] ;
    CharSet   = set of char ;
var
   N : node ;
   i , p1 , p2 , K , Position ,
   TM , XCoor , YCoor , NumPoints , NumCurves , AltX , AltY : INTEGER;

   ScCvPt    : SPairPointer ;
   CvPt      : PairPointer ;
   PrintByte : PBytePointer ;

    UpY     : array[1..640] of integer ;
    LoY     : array[1..640] of integer ;
    UpSY    : array[1..640] of integer ;
    LoSY    : array[1..640] of integer ;
    Hide , First : Boolean ;

   EV : EvenVideo absolute $B800:0000 ;
   OV : OddVideo  absolute $BA00:0000 ;

   DrawLine , DIncr , PLine , CLine , C , C1 , P : integer ;
   CTCP , STCP ,
   SPCT , SPST ,
   SinTheta,SinPhi,CosTheta,CosPhi, Im1 , Im2 , Z , Z1, Z2 ,
   Z3 ,X , Y , Ax , Ay ,
   Zero , Ptime : REAL ;
   Screen , Form , Hidden , LowOrHigh : Boolean ;
   ch,E : char ;
   Equation: string[75] ;
   time1 , time2 : real ;
   a , b , d : integer ;

Procedure Tone ;
   begin
     sound(440) ;
     delay(250) ;
     nosound ;
   end ;

{----------------------------- Time ------------------------------------}

function timer : real ; { *** PTime of type real must be global *** }

type
  regpack = record
              ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
            end;

var
  recpack:          regpack;             {assign record}
  ah,al,ch,cl,dh:   byte;
  hour,min,sec:     integer ;

begin
  ah := $2c;                             {initialize correct registers}
  with recpack do
  begin
    ax := ah shl 8 + al;
  end;
  intr($21,recpack);                     {call interrupt}
  with recpack do
  begin
    hour := cx shr 8 ;
    min  := cx mod 256 ;
    sec  := dx shr 8 ;
  end;
  timer := ((min * 60) + sec) - PTime ;
end;

{------------------ Evaluate formula : Parser Routine -----------------------}

Function BinopNode(opr:char ; lopr , ropr : node) : node ;
    Var n : node ;
    begin
         if (lopr=nil) or (ropr=nil) then BinopNode := Nil
         else begin
              New(n) ;
              with n^ do begin
                   tag := binop ;
                   Operator := opr ;
                   LeftOperand := lopr ;
                   RightOperand := ropr ;
                         end ;
              binopnode := n ;
              end ;
    end ;

Function UnopNode(opr : char ; Opand : node) : node ;
    Var N : node;
    begin
                   New(n) ;
                   with N^ do begin
                   tag := unop ;
                   Uoperator := opr ;
                   Operand := Opand ;
                              end ;
              UnopNode := n ;
    end ;

Function NumberNode(I : real) : node ;
    Var N : node ;
    begin
         New(N) ;
         with n^ do begin
              Tag := Number ;
              Num := I ;
                    end ;
         NumberNode := N ;
    end ;

{**************************************************************************}
procedure Parse(var IsFormula: Boolean; { True if formula}
                   var Formula: AnyString; { Fomula to evaluate}
                   var Value: Node;  { Pointer to first record }
                   var ErrPos: Integer);{ Position of error }
const
  Numbers: set of Char = ['0'..'9'];
  EofLine  = ^M;

var
  Pos: Integer;    { Current position in formula                     }
  Ch: Char;        { Current character being scanned                 }
  EXY: string[3];  { Intermidiate string for conversion              }
  N : Node ;

{ Procedure NextCh returns the next character in the formula         }
{ The variable Pos contains the position ann Ch the character        }

  procedure NextCh;
  begin
    repeat
      Pos:=Pos+1;
      if Pos<=Length(Formula) then
      Ch:=Formula[Pos] else Ch:=eofline;
    until Ch<>' ';
  end  { NextCh };

Procedure PrevCh ;
    begin
    repeat
      if pos>1 then begin
      Pos:=Pos-1;
      Ch:=Formula[Pos]   end ;
    until Ch<>' ';
  end ;

  function Expression: Node;
  var
    N : Node ;
    E: Real;
    Opr: Char;

      function Term: Node;
      var
        N : Node ;
        T: Real;

          function Factor: Node;
          type
              StandardFunction=(fabs,fsqrt,fsqr,fsin,fcos,farctan,fln,flog,
                                fexp,ffact) ;
                                StandardFunctionList = array[standardFunction] of
                                                            string[6] ;
          Const
               StandardFunctionNames: StandardFunctionList=('ABS','SQRT',
                                      'SQR','SIN','COS','ARCTAN','LN',
                                      'LOG','EXP','FACT');

          var
            Found : boolean ;
            F: Real;
            Start , L : integer ;
            Sf : StandardFunction ;

          begin { Function Factor }
            NextCh ;
            if Ch in Numbers then
            begin
              Start:=Pos;
              repeat NextCh until not (Ch in Numbers);
              if Ch='.' then repeat NextCh until not (Ch in Numbers);
              if Ch='E' then
              begin
                NextCh;
                repeat NextCh until not (Ch in Numbers);
              end;
              Val(Copy(Formula,Start,Pos-Start),F,ErrPos);
              Factor := NumberNode(F) ;
              PrevCh ;
            end

            else if Ch = '-' then Factor:=UnopNode(Ch,Factor)
            else if Ch = '(' then begin
                    Factor:=Expression ;
                    nextCh ;
                    if Ch <> ')' then writeln('close parenthesis expected') ;
                                  end

            else if ch in ['X','Y'] then
                 begin
                      Opr:=ch ;
                      Factor := UnopNode(Opr,nil) ;
                 end
            else Begin
                 found:= false ;
                 for sf := Fabs to ffact do
                 if Not found then
                 begin
                      l := length(StandardFunctionNames[sf]) ;
                      if copy(Formula,pos,l)=STandardFunctionNames[sf] then
                      begin
                        Pos := Pos + l - 1 ; nextCh ;
                        N := Expression ; NextCh ;
                        Case sf of
                          fabs     : Factor:=UnopNode('a',N) ;
                          fsqrt    : Factor:=UnopNode('b',N) ;
                          fsqr     : Factor:=UnopNode('c',N) ;
                          fsin     : Factor:=UnopNode('d',N) ;
                          fcos     : Factor:=UnopNode('e',N) ;
                          farctan  : Factor:=UnopNode('f',N) ;
                          fln      : Factor:=UnopNode('g',N) ;
                          flog     : Factor:=UnopNode('h',N) ;
                          fexp     : Factor:=UnopNode('i',N) ;
                          ffact    : Factor:=UnopNode('j',N) ;
                        end ;
                        found := True ;
                      end ;
                  end ;
                  if not found then begin
                      writeln('illegal expression') ;
                      errpos := pos ;
                      Factor := Nil ;
                                    end ;
                end ;
          end { function Factor};

    begin { Term }
      N:=Factor;
      Term := N ;
      if N<>Nil then begin
         NextCh ;
         if (Ch='^') or (Ch='*') or (Ch='/') then   begin
            Term := BinopNode(Ch,N,Term) ;
                                       end
          else PrevCh ;
                     end ;
    end { Term };

  begin { Expression }
    N := Term ;
    Expression := N ;
    if N<>Nil then begin
       NextCh ; Opr := Ch ;
       if (Opr='+') or (Opr='-') then begin
          Expression := BinopNode(Opr,N,Expression) ;
                                    end
        else if Ch<>eofline then
            PrevCh ;
                   end ;
  end { Expression };

begin { procedure Parser }
  if Formula[1]='.' then Formula:='0'+Formula;
  if Formula[1]='+' then delete(Formula,1,1);
  IsFormula:=false;
  Pos:=0;
  Value := Expression ;
  if Ch=EofLine then ErrPos:=0 else ErrPos:=Pos;
end { Evaluate };

{-------------------- Evaluate Parse Tree -----------------------------------}
function Fact(I: Integer): Real;
              begin
                if I > 0 then begin Fact:=I*Fact(I-1); end
                else Fact:=1;
              end  { Fact };

Function Eval(N:node) : Real ;
    Var op1 , op2 , Re : Real ;
        a : integer ;
    Begin
      With N^ do
       Case tag of
         Binop : begin
                   Op1 := Eval(LeftOperand) ;
                   Op2 := Eval(RightOperand) ;
                   Case Operator of
                     '+' : Eval := Op1 + Op2 ;
                     '-' : Eval := Op1 - Op2 ;
                     '*' : Eval := Op1 * Op2 ;
                     '/' : begin
                             if Op2=0 then Op2 := Zero ;
                             Eval := Op1 / Op2 ;
                           end ;
                     '^' : begin
                             Re := Op1 ;
                             for a := 1 to Trunc(Op2-1) do
                                 Re := Re * Op1 ;
                             Eval := Re ;
                           end ;
                   end ;
                 end ;

       Unop  : begin
                   if OPerand<>nil then Op1 := Eval(Operand) ;
                   Case UOperator of
                     '-' : Eval := -Op1 ;
                     'X' : Eval := X ;
                     'Y' : Eval := Y ;
                     'a' : Eval := abs(Op1) ;
                     'b' : Eval := Sqrt(Op1) ;
                     'c' : Eval := Sqr(Op1) ;
                     'd' : Eval := sin(Op1) ;
                     'e' : Eval := Cos(Op1) ;
                     'f' : Eval := arctan(Op1) ;
                     'g' : Eval := Ln(Op1) ;
                     'h' : Eval := ln(Op1)/ln(10) ;
                     'i' : Eval := exp(Op1) ;
                     'j' : Eval := Fact(trunc(Op1)) ;
                   end ;
                 end ;

       Number  : Eval := Num ;

       end ;
   end ;

{---------------------------------------------------------------------------}
{------------------------- Input Routine -----------------------------------}

Procedure Beep ;
    begin
         sound(440) ;
         delay(50) ;
         NoSound ;
    end ;

Procedure Color(F,B : integer) ;
   begin
        TextColor(F) ;
        TextBackGround(B) ;
   end ;

Procedure HighColor ;
   begin
        Color(14,4) ;
   end ;
Procedure LowColor ;
   begin
        Color(15,1) ;
   end ;

Procedure HighLight(Str1 : char) ;
    Var    x,y : integer ;
    begin
         x := wherex ; y := wherey ;
         highcolor ;
         write(str1);
         lowcolor ;
         gotoxy(x,y) ;
    end ;

Procedure Input(Col,Row,Wide:Byte ; TypeSet:Charset ; Stop:Str20 ;
                  Var OutStr:Str80 ; Var Jump:char ) ;

   Label Bend ;
   Var  x1,y1,len : integer ;
        OutPut : string[80] ;
        Ch : char ;

   begin
        OutPut := OutStr ;  Jump := '*' ;
        y1 := Row ;
        Len := Length(OutPut) ; x1 := Len+1 ;
        gotoxy(col,row) ;
        LowColor ;
        write(copy(OutPut+space,1,wide)) ;
        gotoxy(col+x1-1,row) ;
        highlight('_') ;

     Repeat
           read(kbd,Ch) ; len := Length(OutPut) ;

           if Ch in TypeSet then begin
                    if (len<wide) and (x1=len+1) then
                       begin
                            Ch := upcase(Ch) ;
                            OutPut := OutPut + Ch ;
                            gotoxy(col,row) ;
                            write(OutPut) ;
                            x1 := x1 + 1 ; Highlight('_') ;
                       end
                       else if (len<wide) and (x1<len+1) then
                             begin
                              Ch := upcase(Ch) ;
                              insert(Ch,OutPut,x1) ;
                              x1 := x1 + 1 ;
                              gotoxy(col,row) ;
                              write(OutPut) ;
                              gotoxy(col+x1-1,Row) ;
                              highlight(output[x1]) ;
                             end ;
                     if len = wide then Beep ;
                                 end

           Else if Ch = #08 then begin
                           if Len > 0 then begin
                              x1 := x1 - 1 ;
                              delete(OutPut,x1,1) ;
                              gotoxy(col,row) ;
                              write(output,'  ') ;
                              gotoxy(col+x1-1,Row) ;
                              if x1=len then highlight(' ')
                              else highlight(output[x1]) ;
                                            end ;
                            end

           Else if Ch = #27 then begin
                if keypressed then begin
                   read(kbd,jump) ;
                   case jump of
  (* left arrow *)   'K' : if x1 > 1 then begin
                             x1:=x1-1 ;
                             gotoxy(Col+x1,row) ;
                             if x1+1=Len+1 then write(' ')
                             else write(output[x1+1]);
                             gotoxy(Col+x1-1,row) ; highlight(output[x1]) ;
                                          end ;
  (* right arrow *)  'M' : if x1 < len+1 then begin
                             x1 := x1 +1 ;
                             gotoxy(Col+x1-2,row) ; write(output[x1-1]) ;
                             gotoxy(Col+x1-1,row) ;
                             if x1=len+1 then highlight(' ')
                             else highlight(output[x1]) ;
                                              end ;
 (* Home *)          'G' : begin
                             x1 := 1 ;
                             gotoxy(col,row) ; write(output) ;
                             gotoxy(col,row) ; highlight(output[1]) ;
                           end ;
                      'H' : goto Bend ;
                      'P' : goto Bend ;
                      F1  : begin color(15,0) ; clrscr ; halt ; end ;
                   end ;
                                    end
                      Else begin Jump := '^' ;  goto Bend ; end ;
                                  end

           Else if Pos(Ch,Stop)=0 then Beep ;

     Until Pos(Ch,Stop) <> 0 ;
 Bend :
        if OutPut <> '' then OutStr := OutPut ;
        color(11,0) ;
        gotoxy(col,row) ;
        write(copy(OutStr+space,1,wide)) ;
   end ;
{-----------------------------------------------------------------------------}
Procedure InputN(Col,Row,W,D:Byte ; Var Num:real ; Var Jump:char ) ;
   Label Bend ;
   Var  x1,y1,len,code : integer ;
        NumStr : string[80] ;
        Ch : char ;

   begin
        Str(Num:W:D,NumStr) ;                    { Get Number in NumStr }
        while Pos(' ',NumStr)<>0 do              { Delete all spaces    }
          delete(NumStr,Pos(' ',NumStr),1) ;     { from NumStr          }
        Jump := '*' ;
        NumStr:=copy(NumStr+Space,1,W) ;       { add spaces to left justify }
                                               { NumStr is now full width   }
        x1 := 1 ;                              { x1=1 , Cursor Position }
     repeat
        gotoxy(col,row) ;
        LowColor ;
        write(NumStr) ;
        gotoxy(col,row) ;
        highlight(NumStr[1]) ;

     Repeat
           read(kbd,Ch) ; len := Length(NumStr) ;

           if Ch in ['0'..'9','-','.',' '] then begin
                            delete(NumStr,x1,1) ;
                            insert(Ch,NumStr,x1) ;
                            gotoxy(col+x1-1,row) ;
                            write(Ch) ;
                            if x1<W then x1 := x1 + 1 ;
                            gotoxy(col+x1-1,row) ;
                            Highlight(NumStr[x1]) ;
                                                end

           Else if Ch = #08 then begin
                           if x1 > 1 then begin
                              x1 := x1 - 1 ;
                              delete(NumStr,x1,1) ;
                              NumStr := NumStr+' ' ;
                              gotoxy(col,row) ;
                              write(NumStr) ;
                              gotoxy(col+x1-1,Row) ;
                              highlight(NumStr[x1]) ;
                                            end ;
                            end

           Else if Ch = #27 then begin
                if keypressed then begin
                   read(kbd,jump) ;
                   case jump of
  (* left arrow *)   'K' : if x1 > 1 then begin
                             x1:=x1-1 ;
                             gotoxy(col,row) ; write(NumStr) ;
                             gotoxy(Col+x1-1,row) ;
                             highlight(NumStr[x1]) ;
                                          end ;
  (* right arrow *)  'M' : if x1 < W then begin
                             x1 := x1 +1 ;
                             gotoxy(col,row) ; write(NumStr) ;
                             gotoxy(Col+x1-1,row) ;
                             highlight(NumStr[x1]) ;
                                          end ;
                     'H' : goto Bend ;
                     'P' : goto Bend ;
                     F1  : begin color(15,0) ; clrscr ; halt ; end ;
                   end ;
                                    end
                      Else Jump := '^' ;
                                  end

           Else if Ch<>chr(13) then Beep ;

     Until (Ch=chr(13)) or (Jump='^') ;

   Bend : if NumStr <> '' then
          begin
               while Pos(' ',NumStr)<>0 do          { Delete all spaces }
                 delete(NumStr,Pos(' ',NumStr),1) ;
               if NumStr[1]='.' then NumStr := '0'+NumStr ;
               color(11,0) ;
               gotoxy(col,row) ; write(copy(NumStr+space,1,w)) ;
               val(NumStr,Num,code) ;
          end ;

    until code=0 ;
   end ;

{----------------------- Line Routines --------------------------------------}

Procedure LinePoints(X1,Y1,X2,Y2 : integer ) ;
    Var
       x,x3,y,y3,z,a,b,dx,dy,d,deltap,deltag : integer ;

   Procedure PackArray(X,Y : integer ) ;
    Const
         Bits : array[0..7] of byte = (1,2,4,8,16,32,64,128) ;
    Var
       Bit , XInx : Byte ;
    begin
      if ((X>1) and (X<640)) and ((Y<398) and (Y>2)) then
      begin
         XInx := X shr 3 ;
         Bit := x -(XInx shl 3) ;
       PrintByte^[y,XInx] := PrintByte^[y,XInx] or Bits[Bit] ;
      end ;
    end ;

   Function TestY(x,y: integer) : Boolean ;
       begin
         if (X>1) and (X<640) then begin
            TestY:=False ;
            if y<=UpY[x] then TestY:=true ;
            if y>=LoY[x] then TestY:=True ;
                                   end
         else TestY:=False ;
       end ;

    begin
      dx := abs(x2-x1) ;
      dy := abs(y2-y1) ;

      if dy <= dx then
         begin
           x := x1 ; y := y1 ; z := x2 ;
           if x1 <= x2 then a := 1 else a := -1 ;
           if y1 <= y2 then b := 1 else b := -1 ;
           deltap := dy + dy ;
           d      := deltap - dx ;
           deltag := d - dx ;

           if Not Hide then Packarray(x,y)
              else if TestY(x,y) then Packarray(x,y) ;
           while x <> z do begin
              x := x + a ;
              if d<0 then d := d + deltap
                 else begin
                        y := y + b ; d := d + deltag ;
                      end ;
              if Not Hide then Packarray(x,y)
                 else if TestY(x,y) then Packarray(x,y) ;
                           end ;
         end

      else
        begin
          y := y1 ; x := x1 ; z := y2 ;
          if y1 <= y2 then a := 1 else a := -1 ;
          if x1 <= x2 then b := 1 else b := -1 ;
          deltap := dx + dx ;
          d      := deltap - dy ;
          deltag := d - dy ;
          if Not Hide then Packarray(x,y)
             else if TestY(x,y) then Packarray(x,y) ;
          while y <> z do begin
                y := y + a ;
                if d<0 then d := d + deltap
                   else begin
                          x := x + b ; d := d + deltag ;
                        end ;
                if Not Hide then Packarray(x,y)
                   else if TestY(x,y) then Packarray(x,y) ;
                          end ;
       end ;
    end ;    { Pixel_Line }

Procedure SetUpLoY(X1,Y1,X2,Y2 : integer ) ;
    Var
       x,x3,y,y3,z,a,b,dx,dy,d,deltap,deltag : integer ;

   Procedure SetUpLo(x,y : Integer) ;
       begin
         if (X>1) and (X<640) then begin
              if y<UpY[x] then begin
                 if y>1 then UpY[x]:=y
                    else UpY[x]:=1 ;
                               end ;
              if y>LoY[x] then begin
                 if y<399 then LoY[x]:=y
                    else LoY[x]:=399 ;
                               end ;
                                   end ;
       end ;

    begin
      dx := abs(x2-x1) ;
      dy := abs(y2-y1) ;

      if dy <= dx then
         begin
           x := x1 ; y := y1 ; z := x2 ;
           if x1 <= x2 then a := 1 else a := -1 ;
           if y1 <= y2 then b := 1 else b := -1 ;
           deltap := dy + dy ;
           d      := deltap - dx ;
           deltag := d - dx ;
           SetUpLo(x,y) ;
           while x <> z do begin
              x := x + a ;
              if d<0 then d := d + deltap
                 else begin
                        y := y + b ; d := d + deltag ;
                      end ;
              SetUpLo(x,y) ;
                           end ;
         end

      else
        begin
          y := y1 ; x := x1 ; z := y2 ;
          if y1 <= y2 then a := 1 else a := -1 ;
          if x1 <= x2 then b := 1 else b := -1 ;
          deltap := dx + dx ;
          d      := deltap - dy ;
          deltag := d - dy ;
          SetUpLo(x,y) ;
          while y <> z do begin
                y := y + a ;
                if d<0 then d := d + deltap
                   else begin
                          x := x + b ; d := d + deltag ;
                        end ;
                SetUpLo(x,y) ;
                          end ;
       end ;
    end ;    { Pixel_Line }


{---------------------------- Screen Line Routines -----------------------}

Procedure LinePointsS(X1,Y1,X2,Y2 : integer ) ;
    Var
       x,x3,y,y3,z,a,b,dx,dy,d,deltap,deltag : integer ;

   Procedure PackArrayS(X,Y : integer ) ;
    Const
         Bits : array[0..7] of byte = (128,64,32,16,8,4,2,1) ;
    Var
       Bit , XInx : Byte ;
       Ye : integer ;
    begin
      if ((X>128) and (X<639)) and ((Y<199) and (Y>10)) then
        begin
         XInx := X shr 3 ;
         Bit := x -(XInx shl 3) ;
         Ye := y shr 1 ;
         if y mod 2 = 0 then
            EV[ye,XInx] := EV[ye,XInx] or Bits[Bit]
           else OV[ye,XInx] := OV[ye,XInx] or Bits[Bit] ;
        end ;
    end ;

   Function TestY(x,y : Integer) : Boolean ;
       begin
         if (X>1) and (X<640) then begin
              TestY:=False ;
              if y<=UpSY[x] then TestY:=true ;
              if y>=LoSY[x] then TestY:=True ;
                                   end
         else TestY := False ;
       end ;

    begin
      dx := abs(x2-x1) ;
      dy := abs(y2-y1) ;

      if dy <= dx then
         begin
           x := x1 ; y := y1 ; z := x2 ;
           if x1 <= x2 then a := 1 else a := -1 ;
           if y1 <= y2 then b := 1 else b := -1 ;
           deltap := dy + dy ;
           d      := deltap - dx ;
           deltag := d - dx ;

           if Not Hide then PackarrayS(x,y)
              else if TestY(x,y) then PackarrayS(x,y) ;

           while x <> z do begin
              x := x + a ;
              if d<0 then d := d + deltap
                 else begin
                        y := y + b ; d := d + deltag ;
                      end ;
              if Not Hide then PackarrayS(x,y)
                 else if TestY(x,y) then PackarrayS(x,y) ;
                           end ;
         end

      else
        begin
          y := y1 ; x := x1 ; z := y2 ;
          if y1 <= y2 then a := 1 else a := -1 ;
          if x1 <= x2 then b := 1 else b := -1 ;
          deltap := dx + dx ;
          d      := deltap - dy ;
          deltag := d - dy ;
          if Not Hide then PackarrayS(x,y)
             else if TestY(x,y) then PackarrayS(x,y) ;
          while y <> z do begin
                y := y + a ;
                if d<0 then d := d + deltap
                   else begin
                          x := x + b ; d := d + deltag ;
                        end ;

                if Not Hide then PackarrayS(x,y)
                   else if TestY(x,y) then PackarrayS(x,y) ;
                          end ;
       end ;
    end ;    { Pixel_Line }

Procedure SetUpLoYS(X1,Y1,X2,Y2 : integer ) ;
    Var
       x,x3,y,y3,z,a,b,dx,dy,d,deltap,deltag : integer ;


   Procedure SetUpLo(x,y : Integer) ;
       begin
         if (X>1) and (X<640) then begin
              if y<UpSY[x] then begin
                 if y>1 then UpSY[x]:=y
                    else UpSY[x]:=1 ;
                                end ;
              if y>LoSY[x] then begin
                 if y<199 then LoSY[x]:=y
                    else LoSY[x]:=199 ;
                                end ;
                                   end ;
       end ;

    begin
      dx := abs(x2-x1) ;
      dy := abs(y2-y1) ;

      if dy <= dx then
         begin
           x := x1 ; y := y1 ; z := x2 ;
           if x1 <= x2 then a := 1 else a := -1 ;
           if y1 <= y2 then b := 1 else b := -1 ;
           deltap := dy + dy ;
           d      := deltap - dx ;
           deltag := d - dx ;

           SetUpLo(x,y) ;

           while x <> z do begin
              x := x + a ;
              if d<0 then d := d + deltap
                 else begin
                        y := y + b ; d := d + deltag ;
                      end ;
              SetUpLo(x,y) ;
                           end ;
         end

      else
        begin
          y := y1 ; x := x1 ; z := y2 ;
          if y1 <= y2 then a := 1 else a := -1 ;
          if x1 <= x2 then b := 1 else b := -1 ;
          deltap := dx + dx ;
          d      := deltap - dy ;
          deltag := d - dy ;
          SetUpLo(x,y) ;
          while y <> z do begin
                y := y + a ;
                if d<0 then d := d + deltap
                   else begin
                          x := x + b ; d := d + deltag ;
                        end ;
                SetUpLo(x,y) ;
                          end ;
       end ;
    end ;    { Pixel_Line }

{------------------------ Printer Routines ----------------------------------}

Procedure QuitPrint ;
          begin
               gotoxy(2,15) ; write('Stop Print (Y/N) ?') ;
                              read(kbd,ch) ;
               if Upcase(ch) = 'Y' then begin
                                             Halt ;
                                        end ;
          end ;

Procedure LowResPrinter ;
          var
             x , y : integer ;
          begin
             write(lst,^[,'@',^[,'A',chr(8)) ;
             for X := 79 downto 0 do
             begin
               write(lst,^[,'K',chr(144),chr(1)) ;
               for y := 1 to 400 do
                   write(lst,chr(PrintByte^[y,x])) ;
               writeln(lst) ;
               if keypressed then QuitPrint ;
             end ;
             writeln(lst) ;
          end ;

Procedure DoubleWidePrint ;
          var
             X , Y , Y1 , a , b : integer ;
             DoubleByte : array[1..2,1..240] of Byte ;

   Procedure TestBits(Bit ,TestByte : byte ; var Present : Boolean) ;
     const
          Bits : array[1..8] of byte = (254,253,251,247,239,223,191,127) ;
       var
          Test : byte ;
     begin
          Test := TestByte or Bits[Bit] ;
          if Test = 255 then Present := true
             Else Present := False ;
     end ;

   Procedure GetDoubleBytes(X , C : byte) ;
          Const
               Tits : array[1..8] of byte = (3,12,48,192,3,12,48,192) ;
          var
             y : integer ;
             a , b , tit : byte ;
             Present : Boolean ;
          begin
               for  b := 1 to Y1 do
                    begin
                         for Tit := 8 downto 5 do
                             begin
                                  TestBits(tit,PrintByte^[b+c,x],Present) ;
                                  if Present then DoubleByte[1,b] :=
                                     DoubleByte[1,b] or Tits[tit] ;
                                  TestBits(tit-4,PrintByte^[b+c,x],present) ;
                                  if present then DoubleByte[2,b] :=
                                     DoubleByte[2,b] or Tits[tit-4] ;
                             end ;
                    end ;
          end ;

   begin
        b := 0 ; Y1:=240 ;
        for a := 1 to 2 do
          begin
            if a=2 then begin
                          b:=240 ;
                          Y1:=MaxY-240 ;
                        end ;

            write(lst,^[,'@',^[,'A',chr(8)) ;
            for X := 79 downto 0 do
             begin
               fillchar(DoubleByte,sizeof(DoubleByte),0) ;
               GetDoubleBytes(x,b) ;

               write(lst,^[,'K',chr((2*Y1)-256),chr(1)) ;
               for y := 1 to Y1 do
                   write(lst,chr(DoubleByte[1,Y]),chr(DoubleByte[1,Y])) ;
                   if Y1<240 then writeln(lst) ;

               write(lst,^[,'K',chr((2*Y1)-256),chr(1)) ;
               for y := 1 to Y1 do
                   write(lst,chr(DoubleByte[2,Y]),chr(DoubleByte[2,Y])) ;
                   if Y1<240 then writeln(lst) ;

               if keypressed then QuitPrint ;
             end ;
            write(lst,chr(10),chr(10),chr(10),chr(10)) ;
          end ;
   end ;

Procedure PrintStats ;
    begin
         write(lst,#27+#48) ;
         writeln(lst,'Equation: ',equation) ;
        WRITE(lst,'YRot: ',Theta:4:1) ;
        WRITE(lst,'  XRot: ',Phi:4:1) ;
        WRITE(lst,'  Obj : ',Object:3:0) ;
        WRITEln(lst,'  Im : ',Image:4:0) ;
        write(lst,'  XRan: ',HighX:2:0) ;
        write(lst,'  YRan: ',HighY:2:0) ;
        WRITE(lst,'  XInc: ',XIncrement:3:2) ;
        WRITE(lst,'  YInc: ',YIncrement:3:2) ;
        write(lst,'   YTr : ',CenterY:3:0) ;
        write(lst,'   XTr : ',CenterX:3:0) ;
        write(lst,'  ScX : ',ScaleX:3:1) ;
        write(lst,'  ScY : ',ScaleY:3:1) ;
        writeln(lst,chr(12));
    end ;

Procedure WhichPrintout ;
    Var Ch : Char ;
          begin
               gotoxy(2,21) ; write('[S]mall or [L]arge') ;
                              read(kbd,ch) ;
               if Upcase(ch) = 'S' then LowResPrinter ;
               if Upcase(ch) = 'L' then DoubleWidePrint ;
               if (Upcase(ch)='S') or (Upcase(ch)='L') then
                  PrintStats ;
          end ;
{----------------------------------------------------------------------------}

Procedure SetCoor ;
    Var
       XE,YE,ZE ,XX , YY , Fun : REAL;
       aX , aY : integer ;
    BEGIN
        XE:=-X*SinTheta+Y*CosTheta;
        YE:=-X*CTCP-Y*STCP+Z*SinPhi ;
        ZE:=-X*SPCT-Y*SPST-Z*CosPhi+OBJECT ;

        XX := CenterX + Im1*XE/ZE ;
        YY := CenterY - Im2*YE/ZE ;

                     CvPt^[C,P].x := Round(1.1*XX)+60 ;
                     ScCvPt^[C,P].x := Round(xx)+128 ;

                     CvPt^[C,P].y := Round(YY) shl 1 ;
                     ScCvPt^[C,P].y := Round(yy) ;
   END;

PROCEDURE GETSINCOS;
   BEGIN
        SinTheta := SIN(THETA) ;
        SinPhi   := SIN(PHI) ;
        CosTheta := COS(THETA) ;
        CosPhi   := COS(PHI);
        CTCP := CosTheta*CosPhi ;
        STCP := SinTheta*CosPhi ;
        SPCT := SinPhi*CosTheta ;
        SPST := SinPhi*SinTheta ;
   end ;

PROCEDURE GetInfo;
    Var x : integer ;

    BEGIN
      X := 1 ; color(11,0) ;
    repeat
      Case x of
     1:begin
               gotoxy(2,1) ; write('Z:=') ;
               input(5,1,75,[' '..'}'],#13,Equation,E) ;
       end ;
     2:begin   GOTOXY(2,4) ; WRITE('YRot: ') ;
               inputN(7,4,5,1,Theta,E) ;
       end ;
     3:begin   gotoxy(2,5) ; WRITE('XRot: ') ;
               inputN(7,5,5,1,Phi,E) ;
       end ;
     4:begin   gotoxy(2,6) ; WRITE('Obj : ') ;
               inputN(7,6,3,0,object,E) ;
       end ;
     5:begin   gotoxy(2,7) ; WRITE('Im  : ') ;
               inputN(7,7,4,0,image,E) ;
               Im1 := ScaleX*Image ; Im2 := ScaleY*Image ;
       end ;
     6:begin   gotoxy(2,9) ; write('XRan: ') ;
               inputN(7 ,9,2,0,HighX,E) ;
                          LowX := -HighX ;
       end ;
     7:begin   gotoxy(2,10) ; write('YRan: ') ;
               inputN(7 ,10,2,0,HighY,E) ;
                          LowY := -HighY ;
       end ;
     8:begin   gotoxy(2,11) ; WRITE('XInc: ') ;
               inputN(7 ,11,4,2,XIncrement,E) ;
       end ;
     9:begin   gotoxy(2,12) ; WRITE('YInc: ') ;
               inputN(7 ,12,4,2,YIncrement,E) ;
       end ;
    10:begin   gotoxy(2,13) ; WRITE('YTr : ') ;
               inputN(7 ,13,3,0,CenterY,E) ;
       end ;
    11:begin   gotoxy(2,14) ; write('XTr : ') ;
               inputN(7,14,3,0,CenterX,E) ;
       end ;
    12:begin   gotoxy(2,15) ; write('ScX : ') ;
               inputN(7,15,3,1,ScaleX,E) ;
               Im1 := ScaleX * Image ;
       end ;
    13:begin   gotoxy(2,16) ; write('ScY : ') ;
               inputN(7,16,3,1,ScaleY,E) ;
               Im2 := ScaleY * Image ;
       end ;
       end ; { case }
     if (E<>'H') then begin
                 if x<13 then x:=x+1
                  else x:= 1 ;
                      end
      else if x>1 then x:=x-1
              else x:=13 ;

    Until E='^' ;

                END;

PROCEDURE PrintInfo;

    BEGIN
        gotoxy(2,1) ; write('Z:=',Equation) ;
        Gotoxy(2,4) ;  WRITE('YRot: ',Theta:4:1) ;
        gotoxy(2,5) ;  WRITE('XRot: ',Phi:4:1) ;
        gotoxy(2,6) ;  WRITE('Obj : ',Object:3:0) ;
        gotoxy(2,7) ;  WRITE('Im  : ',Image:4:0) ;
        gotoxy(2,9) ;  write('XRan: ',HighX:2:0) ;
        gotoxy(2,10) ; write('YRan: ',HighY:2:0) ;
        gotoxy(2,11) ; WRITE('XInc: ',XIncrement:3:2) ;
        gotoxy(2,12) ; WRITE('YInc: ',YIncrement:3:2) ;
        gotoxy(2,13) ; write('YTr : ',CenterY:3:0) ;
        gotoxy(2,14) ; write('XTr : ',CenterX:3:0) ;
        gotoxy(2,15) ; write('ScX : ',ScaleX:2:1) ;
        gotoxy(2,16) ; write('ScY : ',ScaleY:2:1) ;

    END;

Procedure ClearBitsArray ;
          var X , Y  : integer ;
          begin
               for X := 0 to 79 do
                   begin
                        PrintByte^[1,x]   := 255 ;
                        PrintByte^[2,x]   := 255 ;
                        PrintByte^[3,x]   := 255 ;
                        PrintByte^[398,x] := 255 ;
                        PrintByte^[399,x] := 255 ;
                        PrintByte^[400,x] := 255 ;
                   end ;
               for Y := 4 to 397 do
                   begin
                        PrintByte^[y,0]  := PrintByte^[y,0] or 7 ;
                        PrintByte^[y,79] := PrintByte^[y,79] or 224 ;
                   end ;
          end ;

Procedure BoxIn(x,y,x1,y1:integer) ;
          begin
               draw(x,y,x1,y,11) ;
               draw(x,y,x,y1,11) ;
               draw(x,y1,x1,y1,11) ;
               draw(x1,y,x1,y1,11) ;
          end ;

Procedure graphicInitialize ;
          begin
               HiRes ; HiResColor(11) ;
               PrintInfo ;
               boxin(128,10,639,199) ;

          end ;

Procedure Center(phrase : str80 ; row : integer) ;
    Const Blank = '                                                          ' ;

    Var
      L , SL : integer ;

    begin
      L := Length(phrase) ;
      SL := (80-L) div 2 ;
      gotoxy(1,row) ;
      clreol ;
      write(copy(blank,1,SL),Phrase) ;
    end ;

Procedure Title ;
    begin
      clrscr ;
      Center(' 3D Graph ',10) ;
      center('With printer support for Epson',11) ;
      Center(' by Joe Martin ',12) ;
      Center('8/86',13) ;
      Center(' Ft. Walton Bch. FL ',14) ;
      center(' 1-904-862-7108 ',15) ;
      center(' any key to continue ',25) ;
      repeat until keypressed ;
    end ;

BEGIN  { MAIN PROGRAM }
    clrscr ;
    Equation := '2*COS(0.1*(X^2+Y^2))' ;
    Im1 := ScaleX*Image ; Im2 := ScaleY*Image ;
    Title ;
    clrscr ;

Start :
    Center('ESC - Start Graph     CR or Arrows for menu '+
                '    F1 - Exit', 24) ;
    Ptime := 0.0 ;
    GetInfo ;
    graphicinitialize ;
    X:=LowX ;
    GetSinCos;
    New(ScCvPt) ;
    FillChar(ScCvPt^,SizeOf(ScCvPt^),0) ;
    New(CvPt) ;
    FillChar(CvPt^,SizeOf(CvPt^),0) ;
    New(PrintByte) ;
    FillChar(PrintByte^,SizeOf(PrintByte^),0) ;


    Parse(form,equation,N,Position) ;
    Zero := XIncrement*0.75 ;
    C := 1 ;

  Hide := False ;
  Ptime := timer ;
  NumCurves := Trunc((HighX-LowX)/XIncrement)+1 ;
  while X <= HighX do
  begin
       gotoxy(2,25) ; write(C:2,' ',NumCurves-c:3) ;
       Y := LowY ; P := 1 ;
       Z := Eval(N) ; SetCoor ; P := 2 ; Y := Y + YIncrement ;

       while Y <= HighY do
         begin
              Z := Eval(N) ;
              SetCoor ;

                 LinePointsS(ScCvPt^[c,p].x ,
                     ScCvPt^[c,p].y , ScCvPt^[c,p-1].x , ScCvPt^[c,p-1].y) ;
                 LinePoints(CvPt^[c,p].x ,
                     CvPt^[c,p].y , CvPt^[c,p-1].x , CvPt^[c,p-1].y) ;

              P := P + 1 ;
              Y := Y + YIncrement ;
         end ;
       C := C + 1 ;
       if keypressed then goto Cross ;

       X := X + XIncrement ;
  end ;

Cross :
gotoxy(24,2) ; write(timer:3:2) ; Ptime := 0.0 ;
NumCurves := C-1 ;
Numpoints := Trunc((HighY-LowY)/YIncrement)+1 ;

  gotoxy(2,20) ; write('Hidden(Y/N): ') ; read(kbd,Ch) ;
  if Upcase(Ch) <> 'Y' then goto Finish ;

Ptime := Timer ;
  graphicinitialize ;

  for a := 1 to 640 do
   begin
     UpSY[a]:= 199 ;
     LoSY[a]:= 1 ;
     UpY[a] := 399 ;
     LoY[a] := 1 ;
   end ;

  Hide := True ;
  FillChar(PrintByte^,SizeOf(PrintByte^),0) ;
  a := 0 ;
  for C := NumCurves downto 1 do
    begin
    First:=False ;
    a := a + 1 ; if a=1 then First:=True ;

      for P := 1 to NumPoints-1 do
        begin

          LinePointsS(ScCvPt^[c,p].x ,
                     ScCvPt^[c,p].y , ScCvPt^[c,p+1].x , ScCvPt^[c,p+1].y) ;
          LinePoints(CvPt^[c,p].x ,
                     CvPt^[c,p].y , CvPt^[c,p+1].x , CvPt^[c,p+1].y) ;


        end ;

    if C>1 then begin
      LinePointsS(ScCvPt^[c,p+1].x ,
                     ScCvPt^[c,p+1].y , ScCvPt^[c-1,p+1].x , ScCvPt^[c-1,p+1].y) ;
      LinePoints(CvPt^[c,p+1].x ,
                     CvPt^[c,p+1].y , CvPt^[c-1,p+1].x , CvPt^[c-1,p+1].y) ;
      LinePointsS(ScCvPt^[c,1].x ,
                     ScCvPt^[c,1].y , ScCvPt^[c-1,1].x , ScCvPt^[c-1,1].y) ;
      LinePoints(CvPt^[c,1].x ,
                     CvPt^[c,1].y , CvPt^[c-1,1].x , CvPt^[c-1,1].y) ;
                end ;

      for P := 1 to NumPoints-1 do
        begin
          SetUpLoYS(ScCvPt^[c,p].x ,
                    ScCvPt^[c,p].y , ScCvPt^[c,p+1].x , ScCvPt^[c,p+1].y) ;
          SetUpLoY(CvPt^[c,p].x ,
                   CvPt^[c,p].y , CvPt^[c,p+1].x , CvPt^[c,p+1].y) ;
        end ;

   if C>1 then begin
     SetUpLoYS(ScCvPt^[c,p+1].x ,
                     ScCvPt^[c,p+1].y , ScCvPt^[c-1,p+1].x , ScCvPt^[c-1,p+1].y) ;
     SetUpLoY(CvPt^[c,p+1].x ,
                     CvPt^[c,p+1].y , CvPt^[c-1,p+1].x , CvPt^[c-1,p+1].y) ;
     SetUpLoYS(ScCvPt^[c,1].x ,
                     ScCvPt^[c,1].y , ScCvPt^[c-1,1].x , ScCvPt^[c-1,1].y) ;
     SetUpLoY(CvPt^[c,1].x ,
                     CvPt^[c,1].y , CvPt^[c-1,1].x , CvPt^[c-1,1].y) ;
               end ;
   if keypressed then goto finish ;
    end ;
  Finish :

  ClearBitsArray ;

  GotoXY(1,19) ; write(' DONE ') ;
  gotoxy(24,2) ; write(timer:3:2) ;
  repeat
  gotoxy(2,20) ; writeln('Printout (Y/N)') ;
  Read(kbd,ch) ;
  if Upcase(ch) = 'Y' then WhichPrintout ;
  until Upcase(Ch) <> 'Y' ;
  Dispose(PrintByte) ;
  Dispose(ScCvPt) ;
  Dispose(CvPt) ;
  Dispose(N) ;
  gotoxy(2,21) ; write('Any key To Cont.') ;

REPEAT UNTIL KEYPRESSED ;
TextMode ; goto start ;
 END.  { END PROGRAM }